home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / macros.lisp < prev    next >
Encoding:
Text File  |  1991-11-09  |  16.9 KB  |  528 lines
  1. ;;; -*- Package: MIPS; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: mips-macs.lisp,v 1.46 91/11/09 02:37:41 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains various useful macros for generating MIPS code.
  15. ;;;
  16. ;;; Written by William Lott and Christopher Hoover.
  17. ;;; 
  18.  
  19. (in-package "MIPS")
  20.  
  21. ;;; Handy macro for defining top-level forms that depend on the compile
  22. ;;; environment.
  23.  
  24. (defmacro expand (expr)
  25.   (let ((gensym (gensym)))
  26.     `(macrolet
  27.      ((,gensym ()
  28.         ,expr))
  29.        (,gensym))))
  30.  
  31.  
  32. ;;; Instruction-like macros.
  33.  
  34. (defmacro move (dst src &optional (always-emit-code-p nil))
  35.   "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
  36.   is nil)."
  37.   (once-only ((n-dst dst)
  38.           (n-src src))
  39.     (if always-emit-code-p
  40.     `(inst move ,n-dst ,n-src)
  41.     `(unless (location= ,n-dst ,n-src)
  42.        (inst move ,n-dst ,n-src)))))
  43.  
  44. (defmacro def-mem-op (op inst shift load)
  45.   `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
  46.      `(progn
  47.     (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
  48.     ,,@(when load '('(inst nop))))))
  49. ;;; 
  50. (def-mem-op loadw lw word-shift t)
  51. (def-mem-op storew sw word-shift nil)
  52.  
  53.  
  54. (defmacro load-symbol (reg symbol)
  55.   `(inst add ,reg null-tn (vm:static-symbol-offset ,symbol)))
  56.  
  57. (macrolet
  58.     ((frob (slot)
  59.        (let ((loader (intern (concatenate 'simple-string
  60.                       "LOAD-SYMBOL-"
  61.                       (string slot))))
  62.          (storer (intern (concatenate 'simple-string
  63.                       "STORE-SYMBOL-"
  64.                       (string slot))))
  65.          (offset (intern (concatenate 'simple-string
  66.                       "SYMBOL-"
  67.                       (string slot)
  68.                       "-SLOT")
  69.                  (find-package "VM"))))
  70.      `(progn
  71.         (defmacro ,loader (reg symbol)
  72.           `(progn
  73.          (inst lw ,reg null-tn
  74.                (+ (vm:static-symbol-offset ',symbol)
  75.               (ash ,',offset vm:word-shift)
  76.               (- vm:other-pointer-type)))
  77.          (inst nop)))
  78.         (defmacro ,storer (reg symbol)
  79.           `(inst sw ,reg null-tn
  80.              (+ (vm:static-symbol-offset ',symbol)
  81.             (ash ,',offset vm:word-shift)
  82.             (- vm:other-pointer-type))))))))
  83.   (frob value)
  84.   (frob function))
  85.  
  86. (defmacro load-type (target source &optional (offset 0))
  87.   "Loads the type bits of a pointer into target independent of
  88.   byte-ordering issues."
  89.   (once-only ((n-target target)
  90.           (n-source source)
  91.           (n-offset offset))
  92.     (ecase (backend-byte-order *backend*)
  93.       (:little-endian
  94.        `(inst lbu ,n-target ,n-source ,n-offset ))
  95.       (:big-endian
  96.        `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
  97.  
  98.  
  99. ;;; Macros to handle the fact that we cannot use the machine native call and
  100. ;;; return instructions. 
  101.  
  102. (defmacro lisp-jump (function lip)
  103.   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  104.   `(progn
  105.      (inst addu ,lip ,function (- (ash vm:function-header-code-offset
  106.                     vm:word-shift)
  107.                    vm:function-pointer-type))
  108.      (inst j ,lip)
  109.      (move code-tn ,function)))
  110.  
  111. (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
  112.   "Return to RETURN-PC.  LIP is an interior-reg temporary."
  113.   `(progn
  114.      (inst addu ,lip ,return-pc
  115.        (- (* (1+ ,offset) vm:word-bytes) vm:other-pointer-type))
  116.      (inst j ,lip)
  117.      ,(if frob-code
  118.       `(move code-tn ,return-pc)
  119.       '(inst nop))))
  120.  
  121. (defmacro emit-return-pc (label)
  122.   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
  123.   `(progn
  124.      (align vm:lowtag-bits)
  125.      (emit-label ,label)
  126.      (inst lra-header-word)))
  127.  
  128.  
  129.  
  130. ;;;; Stack TN's
  131.  
  132. ;;; Load-Stack-TN, Store-Stack-TN  --  Interface
  133. ;;;
  134. ;;;    Move a stack TN to a register and vice-versa.
  135. ;;;
  136. (defmacro load-stack-tn (reg stack)
  137.   `(let ((reg ,reg)
  138.      (stack ,stack))
  139.      (let ((offset (tn-offset stack)))
  140.        (sc-case stack
  141.      ((control-stack)
  142.       (loadw reg fp-tn offset))))))
  143.  
  144. (defmacro store-stack-tn (stack reg)
  145.   `(let ((stack ,stack)
  146.      (reg ,reg))
  147.      (let ((offset (tn-offset stack)))
  148.        (sc-case stack
  149.      ((control-stack)
  150.       (storew reg fp-tn offset))))))
  151.  
  152.  
  153. ;;; MAYBE-LOAD-STACK-TN  --  Interface
  154. ;;;
  155. (defmacro maybe-load-stack-tn (reg reg-or-stack)
  156.   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
  157.   (once-only ((n-reg reg)
  158.           (n-stack reg-or-stack))
  159.     `(sc-case ,n-reg
  160.        ((any-reg descriptor-reg)
  161.     (sc-case ,n-stack
  162.       ((any-reg descriptor-reg)
  163.        (move ,n-reg ,n-stack))
  164.       ((control-stack)
  165.        (loadw ,n-reg fp-tn (tn-offset ,n-stack))))))))
  166.  
  167.  
  168. ;;;; Storage allocation:
  169.  
  170. (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
  171.                  &body body)
  172.   "Do stuff to allocate an other-pointer object of fixed Size with a single
  173.   word header having the specified Type-Code.  The result is placed in
  174.   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
  175.   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
  176.   initializes the object."
  177.   `(pseudo-atomic (,temp-tn)
  178.      (inst addu ,result-tn alloc-tn vm:other-pointer-type)
  179.      (inst addu alloc-tn alloc-tn (vm:pad-data-block ,size))
  180.      (inst li ,temp-tn (logior (ash (1- ,size) vm:type-bits) ,type-code))
  181.      (storew ,temp-tn ,result-tn 0 vm:other-pointer-type)
  182.      ,@body))
  183.  
  184.  
  185. ;;;; Three Way Comparison
  186.  
  187. (defun three-way-comparison (x y condition flavor not-p target temp)
  188.   (ecase condition
  189.     (:eq
  190.      (if not-p
  191.      (inst bne x y target)
  192.      (inst beq x y target)))
  193.     (:lt
  194.      (ecase flavor
  195.        (:unsigned
  196.     (inst sltu temp x y))
  197.        (:signed
  198.     (inst slt temp x y)))
  199.      (if not-p
  200.      (inst beq temp zero-tn target)
  201.      (inst bne temp zero-tn target)))
  202.     (:gt
  203.      (ecase flavor
  204.        (:unsigned
  205.     (inst sltu temp y x))
  206.        (:signed
  207.     (inst slt temp y x)))
  208.      (if not-p
  209.      (inst beq temp zero-tn target)
  210.      (inst bne temp zero-tn target))))
  211.   (inst nop))
  212.  
  213.  
  214. ;;;; Simple Type Checking Macros
  215.  
  216. (defmacro simple-test-tag (register temp target not-p tag-type tag-mask)
  217.   `(progn
  218.      (unless (zerop ,tag-mask)
  219.        (inst and ,temp ,register ,tag-mask))
  220.      (inst xor ,temp ,temp ,tag-type)
  221.      (if ,not-p
  222.      (inst bne ,temp zero-tn ,target)
  223.      (inst beq ,temp zero-tn ,target))
  224.      (inst nop)))
  225.  
  226. (defmacro simple-test-simple-type (register temp target not-p type-code)
  227.   "Emit conditional code that test whether Register holds an object with
  228.   the tag specificed if Tag-Type.  Temp should be an unboxed register."
  229.   (once-only ((n-register register)
  230.           (n-temp temp)
  231.           (n-target target)
  232.           (n-not-p not-p)
  233.           (n-type-code type-code))
  234.     `(cond ((< ,n-type-code vm:lowtag-limit)
  235.         (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p
  236.                  ,n-type-code lowtag-mask))
  237.        (t
  238.         ;; Nothing clever in this version.  Assume other-immediate
  239.         ;; type is already in register.
  240.         ;; 
  241.         (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
  242.                  ,n-type-code type-mask)))))
  243.  
  244. (defmacro test-simple-type (register temp target not-p type-code
  245.                      &key (lowtag 'vm:other-pointer-type))
  246.   "Emit conditional code that test whether Register holds an object with
  247.   the tag specificed if Tag-Type.  If the Tag-Type is a type for a heap
  248.   object than the register is dereferencd and the heap object is
  249.   checked.  Temp should be an unboxed register."
  250.   (once-only ((n-register register)
  251.           (n-temp temp)
  252.           (n-target target)
  253.           (n-not-p not-p)
  254.           (n-type-code type-code))
  255.     `(cond ((< ,n-type-code vm:lowtag-limit)
  256.         (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p
  257.                  ,n-type-code vm:lowtag-mask))
  258.        ((or (= ,n-type-code vm:base-char-type)
  259.         (= ,n-type-code vm:unbound-marker-type))
  260.         (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p
  261.                  ,n-type-code vm:type-mask))
  262.        (t
  263.         (let* ((out-label (gen-label))
  264.            (not-other-label (if ,n-not-p ,n-target out-label)))
  265.           (simple-test-tag ,n-register ,n-temp not-other-label t
  266.                    ,lowtag vm:lowtag-mask)
  267.           (load-type ,n-temp ,n-register (- ,lowtag))
  268.           (inst nop)
  269.           (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
  270.                    ,n-type-code 0)
  271.           (emit-label out-label))))))
  272.  
  273.  
  274. ;;;; Hairy Type Checking Macros
  275.  
  276. (defun canonicalize-type-codes (type-codes &optional (shift 0))
  277.   (unless type-codes (return-from canonicalize-type-codes nil))
  278.   (let* ((type-codes (sort (remove-duplicates type-codes) #'<))
  279.      (canonical-type-codes nil)
  280.      (first-type-code (pop type-codes))
  281.      (last-type-code (ash first-type-code shift))
  282.      (range-start first-type-code)
  283.      (range-end nil))
  284.     (dolist (type-code type-codes)
  285.       (let ((shifted-type-code (ash type-code shift)))
  286.     (cond ((= last-type-code (1- shifted-type-code))
  287.            (setf range-end type-code))
  288.           (t
  289.            (push (if range-end (cons range-start range-end) range-start)
  290.              canonical-type-codes)
  291.            (setf range-start type-code)
  292.            (setf range-end nil)))
  293.     (setf last-type-code shifted-type-code)))
  294.     (push (if range-end (cons range-start range-end) range-start)
  295.       canonical-type-codes)
  296.     (nreverse canonical-type-codes)))
  297.  
  298. (defmacro hairy-test-tag (register temp target not-p tag-types tag-mask)
  299.   (let ((in-label (gensym))
  300.     (out-label (gensym)))
  301.     (collect ((emit))
  302.       (macrolet ((frob (value)
  303.            `(let ((diff (+ (- ,value) last-type-code)))
  304.               (unless (zerop diff)
  305.             (emit `(inst add ,temp ,temp ,diff))
  306.             (setf last-type-code ,value)))))
  307.     (do* ((types tag-types (cdr types))
  308.           (type (car types) (car types))
  309.           (last-type-check-p (null (cdr types)) (null (cdr types)))
  310.           (last-type-code 0))
  311.          ((null types))
  312.       (cond ((consp type)
  313.          (let ((low (car type))
  314.                (high (cdr type)))
  315.            (frob low)
  316.            (emit `(inst bltz ,temp ,out-label))
  317.            (frob high)
  318.            (cond (last-type-check-p
  319.               (emit `(if ,not-p
  320.                      (inst bgtz ,temp ,target)
  321.                      (inst blez ,temp ,target))))
  322.              (t
  323.               (emit `(inst blez ,temp ,in-label))))))
  324.         (t
  325.          (frob type)
  326.          (cond (last-type-check-p
  327.             (emit `(if ,not-p
  328.                    (inst bne ,temp zero-tn ,target)
  329.                    (inst beq ,temp zero-tn ,target))))
  330.                (t
  331.             (emit `(inst beq ,temp zero-tn ,in-label))))))))
  332.       `(let* ((drop-through (gen-label))
  333.           (,in-label (if ,not-p drop-through ,target))
  334.           (,out-label (if ,not-p ,target drop-through)))
  335.      ,in-label            ; squelch possible warning
  336.      ,out-label
  337.      (unless (zerop ,tag-mask)
  338.        (inst and ,temp ,register ,tag-mask))
  339.      ,@(emit)
  340.      (inst nop)
  341.      (emit-label drop-through)))))
  342.  
  343. (defmacro test-hairy-type (register temp target not-p &rest types)
  344.   "Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}+
  345.   
  346.   Test whether Register holds a value with one of a specified union of
  347.   type codes.  All low tag type codes will be checked first.  Then the
  348.   pointer will be checked to see if it is an other-pointer-type type
  349.   pointer in which case it will be dereferenced and the remaining type
  350.   codes (the header word type codes) will be checked.  All of the
  351.   type-code expressions are evaluated at macroexpand time.  Temp should
  352.   be an unboxed register." 
  353.   (once-only ((n-register register)
  354.           (n-temp temp)
  355.           (n-target target)
  356.           (n-not-p not-p))
  357.     (unless types (error "Must specify at least one type."))
  358.     ;; 
  359.     ;; Partition the type codes.
  360.     (collect ((low-tag-types)
  361.           (header-word-types))
  362.       (dolist (type types)
  363.     (let ((type (eval type)))
  364.       (cond ((< type vm:lowtag-limit)
  365.          (low-tag-types type))
  366.         (t
  367.          (header-word-types type)))))
  368.       
  369.       (let ((low-tag-types (canonicalize-type-codes (low-tag-types)))
  370.         (header-word-types (canonicalize-type-codes
  371.                 (header-word-types) (- (1- lowtag-bits)))))
  372.     ;; 
  373.     ;; Generate code
  374.     `(let* ((out-label (gen-label))
  375.         (in-low-tag-label (if ,n-not-p out-label ,n-target))
  376.         (not-other-label (if ,n-not-p ,n-target out-label)))
  377.        in-low-tag-label            ; may not be used -- squelch warning
  378.        not-other-label
  379.        ,@(when low-tag-types
  380.            (if header-word-types
  381.            `((hairy-test-tag ,n-register ,n-temp in-low-tag-label nil
  382.                      ,low-tag-types vm:lowtag-mask))
  383.            `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
  384.                      ,low-tag-types vm:lowtag-mask))))
  385.        ,@(when header-word-types
  386.            `((simple-test-tag ,n-register ,n-temp not-other-label t
  387.                   vm:other-pointer-type vm:lowtag-mask)
  388.          (load-type ,n-temp ,n-register (- vm:other-pointer-type))
  389.          (inst nop)
  390.          (hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
  391.                  ,header-word-types 0)))
  392.        (emit-label out-label))))))
  393.  
  394. (defmacro simple-test-hairy-type (register temp target not-p &rest types)
  395.   "Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}+
  396.  
  397.   Test whether Register holds a value with one of a specified union of
  398.   type codes.  The type codes must either be all low tag codes or all
  399.   header word tag codes.  Each separately specified Type is matched, and
  400.   also all types between a Low-Type and High-Type pair (inclusive) are
  401.   matched.  All of the type-code expressions are evaluated at
  402.   macroexpand time.  Temp should be an unboxed register."
  403.   (once-only ((n-register register)
  404.           (n-temp temp)
  405.           (n-target target)
  406.           (n-not-p not-p))
  407.     (unless types (error "Must specify at least one type."))
  408.     ;; 
  409.     ;; Partition the type codes.
  410.     (collect ((low-tag-types)
  411.           (header-word-types))
  412.       (dolist (type types)
  413.     (cond ((< type vm:lowtag-limit)
  414.            (low-tag-types type))
  415.           (t
  416.            (header-word-types type))))
  417.       (let ((low-tag-types (low-tag-types))
  418.         (header-word-types (header-word-types)))
  419.     (cond ((and low-tag-types header-word-types)
  420.            (error "SIMPLE-TEST-HAIRY-TYPE cannot check both low tag ~
  421.            types and other-pointer-type tag types."))
  422.           (low-tag-types
  423.            `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
  424.                  ,(canonicalize-type-codes low-tag-types)
  425.                  vm:lowtag-mask)))
  426.           (header-word-types
  427.            `(progn
  428.           (inst srl ,n-temp ,n-register vm:lowtag-bits)
  429.           (hairy-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
  430.                   ,(canonicalize-type-codes header-word-types)
  431.                   vm:type-mask)))
  432.           (t
  433.            (error "Lost big.  Should not be here.")))))))
  434.  
  435.  
  436. ;;;; Error Code
  437.  
  438.  
  439. (defvar *adjustable-vectors* nil)
  440.  
  441. (defmacro with-adjustable-vector ((var) &rest body)
  442.   `(let ((,var (or (pop *adjustable-vectors*)
  443.            (make-array 16
  444.                    :element-type '(unsigned-byte 8)
  445.                    :fill-pointer 0
  446.                    :adjustable t))))
  447.      (setf (fill-pointer ,var) 0)
  448.      (unwind-protect
  449.      (progn
  450.        ,@body)
  451.        (push ,var *adjustable-vectors*))))
  452.  
  453. (eval-when (compile load eval)
  454.   (defun emit-error-break (vop kind code values)
  455.     (let ((vector (gensym)))
  456.       `((let ((vop ,vop))
  457.       (when vop
  458.         (note-this-location vop :internal-error)))
  459.     (inst break ,kind)
  460.     (with-adjustable-vector (,vector)
  461.       (write-var-integer (error-number-or-lose ',code) ,vector)
  462.       ,@(mapcar #'(lambda (tn)
  463.             `(let ((tn ,tn))
  464.                (write-var-integer (make-sc-offset (sc-number
  465.                                    (tn-sc tn))
  466.                                   (tn-offset tn))
  467.                           ,vector)))
  468.             values)
  469.       (inst byte (length ,vector))
  470.       (dotimes (i (length ,vector))
  471.         (inst byte (aref ,vector i))))
  472.     (align vm:word-shift)))))
  473.  
  474. (defmacro error-call (vop error-code &rest values)
  475.   "Cause an error.  ERROR-CODE is the error to cause."
  476.   (cons 'progn
  477.     (emit-error-break vop vm:error-trap error-code values)))
  478.  
  479.  
  480. (defmacro cerror-call (vop label error-code &rest values)
  481.   "Cause a continuable error.  If the error is continued, execution resumes at
  482.   LABEL."
  483.   `(progn
  484.      (inst b ,label)
  485.      ,@(emit-error-break vop vm:cerror-trap error-code values)))
  486.  
  487. (defmacro generate-error-code (vop error-code &rest values)
  488.   "Generate-Error-Code Error-code Value*
  489.   Emit code for an error with the specified Error-Code and context Values."
  490.   `(assemble (*elsewhere*)
  491.      (let ((start-lab (gen-label)))
  492.        (emit-label start-lab)
  493.        (error-call ,vop ,error-code ,@values)
  494.        start-lab)))
  495.  
  496. (defmacro generate-cerror-code (vop error-code &rest values)
  497.   "Generate-CError-Code Error-code Value*
  498.   Emit code for a continuable error with the specified Error-Code and
  499.   context Values.  If the error is continued, execution resumes after
  500.   the GENERATE-CERROR-CODE form."
  501.   (let ((continue (gensym "CONTINUE-LABEL-"))
  502.     (error (gensym "ERROR-LABEL-")))
  503.     `(let ((,continue (gen-label)))
  504.        (emit-label ,continue)
  505.        (assemble (*elsewhere*)
  506.      (let ((,error (gen-label)))
  507.        (emit-label ,error)
  508.        (cerror-call ,vop ,continue ,error-code ,@values)
  509.        ,error)))))
  510.  
  511.  
  512. ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
  513. ;;;
  514. (defmacro pseudo-atomic ((ndescr-temp) &rest forms)
  515.   (let ((label (gensym "LABEL-")))
  516.     `(let ((,label (gen-label)))
  517.        (inst and flags-tn flags-tn (logxor (ash 1 interrupted-flag) #Xffff))
  518.        (inst or flags-tn flags-tn (ash 1 atomic-flag))
  519.        ,@forms
  520.        (inst and flags-tn flags-tn (logxor (ash 1 atomic-flag) #Xffff))
  521.        (inst and ,ndescr-temp flags-tn (ash 1 interrupted-flag))
  522.        (inst beq ,ndescr-temp zero-tn ,label)
  523.        (inst nop)
  524.        (inst break vm:pending-interrupt-trap)
  525.        (emit-label ,label))))
  526.  
  527.  
  528.